home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / graphic / tpega.zip / SIERP.PAS < prev    next >
Pascal/Delphi Source File  |  1986-02-01  |  3KB  |  118 lines
  1.  program Sierpinski(input,output);
  2. {This program was taken from N. Wirth, "Algorithms + Data Structures =
  3. Programs, Prentice-Hall, 1976.  Further information on Sierpinski curves
  4. may be found in "Creative Computing", July 1984.}
  5.  
  6. {$U-   Change the "-" to a "+" if you want Ctrl-Break to interrupt.}
  7.  
  8. {The parameters below are set to draw Sierpinski curves up to level 6.
  9. When the "?" appears pressing "x" will exit the program.  Pressing any
  10. other key will change the palette.}
  11.  
  12. const n=6;h0=256;
  13. type AString = String[80];
  14. var i,h,x,y,x0,y0,plotcolor : integer;
  15.  
  16. {$I GPParms.p }
  17. {$I GPInit.p  }
  18. {$I GPTerm.p  }
  19. {$I GPPal.p   }
  20. {$I GPColor.p }
  21. {$I GPMOVE.P  }
  22. {$I GPLINE.P  }
  23. {$I GPSCALE.P }
  24. {$I GPCLIP2.P }
  25. {$I GPVIEWPO.P }
  26. {$I GPWINDOW.P }
  27. {$I WORLD.P   }
  28.  
  29. procedure CenterLine(ThisString : AString; xcoord, ycoord: integer);
  30. begin
  31. xcoord := xcoord + 20 - length(ThisString) div 2;
  32. gotoxy(xcoord,ycoord);
  33. write(ThisString);
  34. end;
  35.  
  36. procedure Initialize;
  37. begin
  38.   GPPARMS;
  39.   GPInit;
  40.   CenterLine('Sierpinski Curve',1,1);
  41.   SetWindow(0,0,255,255);
  42.   SetViewport(0,14,GDMAXCOL,GDMAXROW);
  43.   GPCOLOR(1);
  44. end;
  45.  
  46. procedure plotline;
  47. begin
  48.   GPColor(plotcolor);
  49.   LnAbs(x,y);
  50.  
  51. end;
  52.  
  53. procedure setplot;
  54. begin
  55.   MovAbs(x,y);
  56. end;
  57.  
  58. procedure A(i:integer); forward;
  59. procedure B(i:integer); forward;
  60. procedure C(i:integer); forward;
  61. procedure D(i:integer); forward;
  62.  
  63. procedure A;
  64. begin if i > 0 then
  65.     begin A(i-1);x:= x+h;y:=y-h;plotline;
  66.           B(i-1);x:= x+2*h;plotline;
  67.           D(i-1);x:=x+h;y:=y+h;plotline;
  68.           A(i-1)
  69.     end
  70. end;
  71.  
  72. procedure B;
  73. begin if i > 0 then
  74.     begin B(i-1);x:=x-h;y:=y-h;plotline;
  75.           C(i-1);y:=y-2*h;plotline;
  76.           A(i-1);x:=x+h;y:=y-h;plotline;
  77.           B(i-1)
  78.     end
  79. end;
  80.  
  81. procedure C;
  82. begin if i > 0 then
  83.     begin C(i-1);x:=x-h; y:=y+h;plotline;
  84.           D(i-1);x:=x-2*h;plotline;
  85.           B(i-1);x:=x-h;y:=y-h;plotline;
  86.           C(i-1)
  87.     end
  88. end;
  89.  
  90. procedure D;
  91. begin if i > 0 then
  92.     begin D(i-1);x:=x+h;y:=y+h;plotline;
  93.           A(i-1);y:=y+2*h;plotline;
  94.           c(i-1);x:=x-h;y:=y+h;plotline;
  95.           D(i-1)
  96.     end
  97. end;
  98.  
  99. begin
  100. initialize;
  101. plotcolor := 1;
  102. i := 0; h:=h0 div 4; x0 := 2*h; y0 :=3*h;
  103. repeat
  104.   i:=i+1;x0:=x0-h;
  105.   h:=h div 2; y0:=y0+h;
  106.   x:=x0;y:=y0;setplot;
  107.   A(i);x:=x+h;y:=y-h;plotline;
  108.   B(i);x:=x-h;y:=y-h;plotline;
  109.   C(i);x:=x-h;y:=y+h;plotline;
  110.   D(i);x:=x+h;y:=y+h;plotline;
  111.   plotcolor := plotcolor + 1;if plotcolor > 8 then plotcolor := 1;
  112.   gotoxy(39,25); write(i);
  113.   until i = n;
  114. gotoxy(0,0);
  115. readln;
  116. GPTERM;
  117. end.
  118.